home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / schmlbrr / schem_lb.lha / unsupported / CScheme / scoops-example.scm < prev    next >
Encoding:
Text File  |  1993-07-16  |  2.6 KB  |  90 lines
  1. ;;; A SCOOPS example, from the MacScheme distribution
  2.  
  3. (define-class location
  4.   (classvars (w 'baker)(u 'able))
  5.   (instvars (x 400) 
  6.             (y (active 500 (lambda (x)(display "get method ") x)
  7.                            (lambda (x)(display "set method ") x))))
  8.   (options gettable-variables settable-variables inittable-variables))
  9.  
  10. (define-class support
  11.   (instvars (price 0) (material 'wood))
  12.   (mixins location)
  13.   (options gettable-variables settable-variables inittable-variables))
  14.  
  15.  
  16. ;;; The next two examples illustrate two classes with a common
  17. ;;; lexical environment. Because chairs mixin furniture and support methods
  18. ;;; and a furniture method refers to the bound variable lex, chairs must
  19. ;;; be defined in the same environment as furniture. No error will be detected
  20. ;;; if this is violated, but in this case, the variable lex refered to in 
  21. ;;; chair will be distinct from the variable lex refered to in furniture.
  22.  
  23. (let ((lex 'baz))
  24.   ;This example shows how to define instance methods.
  25.   (define-class furniture
  26.     (instvars (price 0) (purpose 'sitting))
  27.     (mixins location)
  28.     (options gettable-variables settable-variables inittable-variables))
  29.  
  30.   (define-method (furniture print-lex) ()
  31.     (display lex)
  32.     (newline))
  33.  
  34.   (define-method (furniture move) (deltax deltay)
  35.     (set! x (+ x deltax))
  36.     (set! y (+ y deltay)))
  37.  
  38.   (define-method (furniture set-lex) (x)
  39.     (set! lex x)) 
  40.   
  41.   ;In the following, the important point is that material is not settable
  42.   ;in a chair even though it is settable in support and chair 
  43.   ;inherits from support. The reason is that material in chair shadows
  44.   ;material in support and material is excluded from the settable variables
  45.   ;in the definition of chair.
  46.   
  47.   
  48.   (define-class chair
  49.     (instvars (number-of-legs 4)(material 'metal))
  50.     (mixins furniture support)
  51.     (options gettable-variables 
  52.              (settable-variables number-of-legs)
  53.              inittable-variables)))
  54.  
  55.  
  56. ;;; sanity checks:
  57.  
  58. (all-classvars chair)
  59. (all-instvars chair)
  60. (all-methods chair)
  61. (class-compiled? chair)
  62. (define ch1 (make-instance chair 'x 500 'y 500))
  63. (class-compiled? chair)
  64. (class-of-object ch1)
  65. (classvars chair)
  66. (describe chair)
  67. (getcv chair u)
  68. (setcv chair u 'charlie)
  69. (getcv chair u)
  70. (instvars chair)
  71. (methods chair)
  72. (mixins chair)
  73. (name->class 'chair)
  74. (rename-class (chair newchair))
  75. (name->class 'newchair)
  76. (send-if-handles ch1 foo)
  77. (send ch1 set-y 500)
  78. (define-method (location row)
  79.   (z)(+ x y z))
  80. (all-methods chair)
  81. ;;; there will be a brief pause while chair is recompiled:
  82. (define ch2 (make-instance chair))
  83. (send ch2 row 5)
  84. (send ch2 set-x 40)
  85. (send ch2 set-y 50)
  86. (send ch2 row 10)
  87.  
  88.  
  89.  
  90.